home *** CD-ROM | disk | FTP | other *** search
/ Delphi Magazine Collection 2001 / Delphi Magazine Collection 20001 (2001).iso / DISKS / Issue56 / Clinic / MemoEgU.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  2000-01-19  |  2.2 KB  |  91 lines
  1. unit MemoEgU;
  2.  
  3. interface
  4.  
  5. uses
  6.   WinProcs, WinTypes, Messages, SysUtils, Classes, Graphics, Controls, Forms,
  7.   Dialogs, StdCtrls;
  8.  
  9. type
  10.   TForm1 = class(TForm)
  11.     Memo1: TMemo;
  12.     procedure Memo1Change(Sender: TObject);
  13.   private
  14.     { Private declarations }
  15.   public
  16.     { Public declarations }
  17.   end;
  18.  
  19. var
  20.   Form1: TForm1;
  21.  
  22. implementation
  23.  
  24. {$R *.DFM}
  25.  
  26. type
  27.   TWCAccess = class(TWinControl);
  28.  
  29. function TextHeight(Ctrl: TWinControl; const Msg: String): Integer;
  30. var
  31.   DC: HDC;
  32.   OldFont: HFont;
  33.   Size: TSize;
  34. begin
  35.   { Can't just ask a control for the font height, as Delphi }
  36.   { caches the font and doesn't select it into the device }
  37.   { context until some drawing is required. }
  38.   { The memo may have a different font to its form and under }
  39.   { those circumstances, you could get bad results. }
  40.  
  41.   { Access control's device context }
  42.   DC := GetDC(Ctrl.Handle);
  43.   try
  44.     { Ensure font is selected into DC (saving old font) }
  45.     OldFont := SelectObject(DC, TWCAccess(Ctrl).Font.Handle);
  46.     try
  47.       { Find text height }
  48.     {$ifdef Win32}
  49.       Win32Check(GetTextExtentPoint32(DC, PChar(Msg), 1, Size));
  50.     {$else}
  51.       GetTextExtentPoint(DC, @(Msg[1]), 1, Size);
  52.     {$endif}
  53.       Result := Size.cy
  54.     finally
  55.       { Put old font back into memo }
  56.       SelectObject(DC, OldFont)
  57.     end;
  58.   finally
  59.     { Let the DC go }
  60.     ReleaseDC(Ctrl.Handle, DC)
  61.   end;
  62. end;
  63.  
  64. procedure TForm1.Memo1Change(Sender: TObject);
  65. var
  66.   Memo: TMemo;
  67.   MemoNumLines: Integer;
  68.   OldSelStart, OldSelLength: Integer;
  69. begin
  70.   if Sender is TMemo then
  71.     Memo := TMemo(Sender)
  72.   else
  73.     Exit;
  74.   MemoNumLines := Memo.ClientHeight div TextHeight(Memo, 'X');
  75.   { Record where we were }
  76.   OldSelStart := Memo.SelStart;
  77.   OldSelLength := Memo.SelLength;
  78.   { Would use the Count property of Lines, but }
  79.   { this doesn't count a blank line at the end }
  80.   { if Memo.Lines.Count > MemoNumLines then }
  81.   if Memo.Perform(EM_GETLINECOUNT, 0, 0) > MemoNumLines then
  82.     Memo.ScrollBars := ssVertical
  83.   else
  84.     Memo.ScrollBars := ssNone;
  85.   { Go back to old position after memo control (possibly) recreated }
  86.   Memo.SelStart := OldSelStart;
  87.   Memo.SelLength := OldSelLength;
  88. end;
  89.  
  90. end.
  91.